home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Clone / tree.f < prev   
Encoding:
FORTH Source  |  1992-06-01  |  16.3 KB  |  708 lines

  1.  
  2. \ TracePFA ( pfa -- ) analyze word, mark as referenced. If word
  3. \ calls others, recursively analyze ALL SUB-words until all are known.
  4.  
  5. decimal
  6.  
  7. only forth definitions
  8.  
  9. ANEW TASK-TREE.F
  10.  
  11. .need CFATable>
  12. defer CFATable>   ' noop is CFATable>
  13. .then
  14.  
  15.  
  16. variable Tracking   \ user turns this on for mem & file allocation tracking
  17.                     \ in his target image
  18.  
  19. variable NoConsole  \ if true, clone dummy code for
  20.                     \ KEY, EMIT, ?TERMINAL
  21.  
  22. \ variable NoAmiga    \ Don't include Amiga startupcode...
  23.                     \ The "main" ap can load the executable in and
  24.                     \ CALL it
  25.  
  26. global-defer FreeOverlay     ' drop is FreeOverlay
  27.  
  28. variable CloneOverlay  \ if true, save 'References' -> MasterRef when CLONE done
  29.  
  30. also TGT definitions
  31.  
  32.  
  33. \ Record-keeping Stacks ... entries made for each referenced pfa...
  34.  
  35.  
  36. 0 DynamicStack References  \ Sorted stack of called addresses...
  37. 0 DynamicStack RefPackets  \ 'References' index also index for here...
  38.                            \ index holds address of 'Packet', described below.
  39.  
  40. 0 DynamicStack MasterRefs  \ holds references for 'master' program
  41. 0 DynamicStack MasterRefPackets   \ ref packets for 'master'
  42. variable CloneInputCFA \ CFA of word passed to CLONE command
  43. variable OverlaysDefined
  44.  
  45. 128 DynamicStack Substitutes  \ so 'FIND' doesn't run so much
  46. 128 DynamicStack SubCFAs
  47.  
  48. EXISTS? status? .IF
  49.    : NumRefs  ReferencesBase freecell  ;   ' numrefs is #Cloned
  50. .THEN
  51.  
  52. : FreeMaster ( -- )
  53.   MasterRefsVAR FreeStack
  54.   MasterRefPacketsVAR @&FreeBlocks
  55. ;
  56.  
  57. also forth definitions
  58.  
  59. variable KeepMaster
  60.  
  61. : InitClone
  62.   CloneOverLay @
  63.   IF
  64.      MasterRefsVAR @ 0=
  65.      IF
  66.         ReferencesVAR @
  67.         IF
  68.            ReferencesBASE MasterRefsVAR !
  69.            RefPacketsBASE MasterRefPacketsVAR !
  70.            ReferencesVAR off
  71.            RefPacketsVAR off
  72.            >newline ." Ready to CLONE overlays" cr
  73.          THEN
  74.      ELSE
  75.         KeepMaster @
  76.         IF
  77.            false
  78.         ELSE
  79.            >newline ." Finished CLONE-ing overlays?" Y/N
  80.         THEN
  81.         IF
  82.            FreeMaster
  83.            ' drop is FreeOverlay   OverlaysDefined off
  84.            CloneOverLay off
  85.         THEN
  86.      THEN
  87.   ELSE
  88.      MasterRefsVAR @
  89.      IF
  90.         FreeMaster
  91.      THEN
  92.   THEN
  93.   ReferencesVAR FreeStack
  94.   RefPacketsVAR @&FreeBlocks
  95.   SubstitutesVAR FreeStack
  96.   SubCFAsVAR FreeStack
  97.   InitClone
  98.   KeepMaster off
  99. ;
  100.  
  101. : NewOverlay  ( -- )
  102.   KeepMaster on
  103.   " INITCLONE" find
  104.   IF
  105.      execute
  106.   ELSE
  107.      KeepMaster off  >newline " Can't FIND 'INITCLONE'" $error
  108.   THEN
  109. ;
  110.  
  111. previous definitions
  112.  
  113.  
  114. variable CFABase  \ holds CFA of word we ate tracing or cloning...
  115.  
  116. \ and a sample-definition...
  117.  
  118. \ Global-Defer Sample-Defer   ' (pushadr) is Sample-Defer
  119.  
  120. : Sample-Defer  (pushadr) @execute  ;  $ 4e75 w,  ' (pushadr)  ,
  121.  
  122.  
  123. \ RefPacket definition and handlers ...
  124.  
  125.  
  126. :struct RefPacket
  127.    ubyte Ref_IsPFA      \ it non-zero, called address IS a legal pfa.
  128.    ubyte Ref_Resolved   \ true if defined in the targetimage.
  129.    ulong Ref_#Times     \ #times this PFA is called
  130.    ulong Ref_TgtAdr     \ Target relative resolved address
  131. ;struct
  132.  
  133.  
  134. \   This is a foolproof method for figuring how much space exists from
  135. \ a given location to the following NFA.
  136.  
  137.  
  138. variable StartArea    variable MinDiff
  139.  
  140.  
  141. .NEED asm
  142. : ClosestNFA?  ( nfa -- )  dup startarea @ >=
  143.   IF
  144.      startarea @ -   mindiff @ min  mindiff !
  145.   ELSE
  146.      drop
  147.   THEN
  148. ;
  149. .ELSE
  150. asm ClosestNFA?  ( nfa -- )
  151.      move.l   #[StartArea],a0    never do this, since this code
  152.      cmp.l    0(org,a0.l),tos    will never clone, it's ok here
  153.      blt      1$
  154.        move.l   #[MinDiff],a1    a0=StartArea    
  155.        add.l    org,a1        a1=MinDiff(abs)
  156.        sub.l    0(org,a0.l),tos
  157.        cmp.l    (a1),tos
  158.        bge      1$
  159.          move.l   tos,(a1)
  160. 1$:  move.l   (dsp)+,tos
  161. end-code
  162. .THEN
  163.  
  164. .NEED asm
  165. : ClosestVOC?  ( voc-link -- )
  166.   vlink>'  >name  ClosestNFA?
  167. ;
  168. .ELSE
  169. asm ClosestVOC?  ( voc-link -- )
  170.      subq.l  #8,tos
  171.      callcfa >name
  172.      callcfa ClosestNFA?
  173. end-code
  174. .THEN
  175.  
  176. : NextLFA   ( ?addr -- next-LFA-above )
  177.    StartArea !   [ -1 u2/ ] literal mindiff !
  178.   ' ClosestNFA?  is when-scanned
  179.   ' ClosestVOC?  is when-voc-scanned    scan-all-vocs
  180.   mindiff @  [ -1 u2/ ] literal =
  181.   IF
  182.        here StartArea @ -  0 max  mindiff !
  183.   ELSE
  184.        -4 mindiff +!
  185.   THEN
  186.   StartArea @  mindiff @ +
  187. ;
  188.  
  189. : <ValPFA?>   ( 0 pfa -- flag dummy )
  190. ;
  191.  
  192. : ValidPFA?  ( pfa -- flag )
  193.   0 swap
  194.   dup cell- @  $ 0070,f800 and 0=    ( -- 0 pfa flag )
  195.   IF
  196.      \ a rational size code exists...
  197.      dup >name dup Valid-Name?        ( -- 0 pfa nfa? flag )
  198.      IF 
  199.         \ the name-field seems to make sense...
  200.         name> over =      ( -- 0 pfa flag )
  201.         IF
  202.            \ going back to the pfa gives the original adr, it's good!
  203.            2drop true dup
  204.         THEN
  205.      ELSE
  206.         drop
  207.      THEN
  208.   THEN
  209.   drop
  210. ;
  211.  
  212. : >CFA  ( adr? -- cfa )
  213.   BEGIN
  214.      dup ValidPFA? 0=
  215.   WHILE
  216.      2-
  217.   REPEAT
  218. ;
  219.  
  220. : IsValuePFA?  ( pfa? -- flag )
  221.   dup validpfa?  dup   ( -- adr flag flag )
  222.   IF
  223.      drop dup cell- @  $ f,0000 and VALUE_ID =
  224.   THEN
  225.   swap drop
  226. ;
  227.  
  228. 0 .IF
  229. defer  JustForParent  ' justforParent >parent
  230. forget JustForParent
  231. constant DeferParent
  232. .THEN
  233.  
  234. : GETNAME  ( cfa -- , move fullname to HERE )
  235.   >name   dup c@  $ 1f and dup >r  1+  ( -- nfa count+1 )
  236.   here swap move   r> here c!
  237. ;
  238.  
  239.  
  240. : SUBSTITUTE?   ( cfa -- cfa' )
  241.   dup CloneInputCFA @ =  CloneOverlay @ AND  ?exit
  242.   \
  243.   dup >r  dup ValidPFA?
  244.   IF
  245.      dup Substitutes StackFind  ( -- cfa index flag )  2dup 2 x>r
  246.      ( -r- cfa flag index )
  247.      IF
  248.         SubCFAsBASE stack@  ( -- cfa newcfa )
  249.         dup ' Redefs ' RedefsEnd within?   ( -- cfa newcfa flag )
  250.         IF
  251.            drop true
  252.         ELSE
  253.            nip false
  254.         THEN
  255.      ELSE
  256.         drop true
  257.      THEN  ( -- cfa? flag )
  258.      IF
  259.         1 rpick  0=
  260.         IF
  261.            dup r@  ( -- cfa cfa ix )  Substitutes  StackInsert
  262.         THEN
  263.         dup GETNAME
  264.         \
  265.         NoConsole @
  266.         IF
  267.            only IORedefs definitions  here find
  268.            IF
  269.               dup CFABase @ -
  270.               IF
  271.                   ( -- cfa cfa2 )  swap
  272.               THEN
  273.            THEN
  274.            only forth definitions drop
  275.         THEN
  276.         \
  277.         dup 2 rpick =  ( not found in redefs )
  278.         Tracking @ 0= and  ( notracking wanted )
  279.         IF
  280.            only AllocRedefs definitions  here find
  281.            IF
  282.               dup CFABase @ -
  283.               IF
  284.                   ( -- cfa cfa2 )  swap
  285.               THEN
  286.            THEN
  287.            only forth definitions drop
  288.         THEN
  289.         dup 2 rpick =  ( still not found )
  290. [ 1 .if ]
  291.         IF
  292.            only redefs definitions  here find
  293.            IF
  294.               dup CFABase @ -
  295.               IF
  296.                   ( -- cfa cfa2 )  swap
  297.               THEN
  298.            THEN
  299.            only forth definitions drop
  300.         THEN
  301. [ .else ]
  302.         NoConsole @ and
  303.         IF
  304.            only IORedefs definitions  here find
  305.            IF
  306.               dup CFABase @ -
  307.               IF
  308.                   ( -- cfa cfa2 )  swap
  309.               THEN
  310.            THEN
  311.            only forth definitions drop
  312.         THEN
  313. [ .then ]
  314.         \
  315.         1 rpick 0=
  316.         IF
  317.            dup r@  ( -- cfa2 cfa2 ix )  SubCFAs  StackInsert
  318.         THEN
  319.      THEN
  320.      2 xrdrop
  321.   THEN
  322.   rdrop
  323. ;
  324.  
  325.  
  326. : <CreatePacket>   ( pfa index -- address )   >r
  327.   MEMF_CLEAR  sizeof() RefPacket  allocblock?  ( -- pfa pktadr )
  328.   dup r> RefPackets StackInsert       ( -- pfa pktadr )
  329.   swap ValidPFA? over ..! Ref_IsPFA   ( -- pktadr )
  330. ;
  331.  
  332.  
  333. : <CreateReference>  ( pfa index -- packetaddr )
  334.   2dup  References  StackInsert  ( -- pfa index )   <CreatePacket>
  335. ;
  336.  
  337.  
  338. variable IfCreateRefs      Global-Defer TrapPacket
  339. variable InMaster
  340.  
  341. : PacketFor  ( pfa -- Packet-Base )
  342.   InMaster off
  343.   MasterRefsVAR @
  344.   IF
  345.      dup MasterRefs StackFind  ( -- pfa index flag )
  346.      dup InMaster !
  347.   ELSE
  348.      0 0
  349.   THEN
  350.   IF
  351.      cells MasterRefPacketsBase + @ ( -- pfa pktaddr )  nip
  352.   ELSE
  353.      drop
  354.      dup References StackFind   ( -- pfa index flag )
  355.      IF
  356.           \ it exists...
  357.           cells RefPacketsBase + @ ( -- pfa pktaddr )
  358.      ELSE
  359.           IfCreateRefs @
  360.           IF
  361.              \ 1st time referenced ...
  362.              <CreateReference> dup ( -- pktadr pktadr )
  363.           ELSE
  364.              \ error...shouldn't be extending ref tables...
  365.              ( -- pfa pktaddr )  TrapPacket  quit
  366.           THEN
  367.      THEN
  368.      nip
  369.   THEN
  370. ;
  371.  
  372. : CFA>Tgt  ( dictcfa -- tgtadr )
  373.   PacketFor dup ..@ ref_Resolved   ( -- packet flag )
  374.   IF
  375.      ..@ ref_TgtAdr
  376.   ELSE
  377.      \
  378.      \ not built in target yet...
  379.      \
  380.      >newline
  381.      ." DICT>TGT: "  >name ID. ."  referenced but not built" quit 
  382.   THEN
  383. ;
  384.  
  385. : Dict>TGT  ( dictadr -- tgtaddr , call only after everthing built! )
  386.   dup ValidPFA?
  387.   IF
  388.      \
  389.      \ the address IS a cfa
  390.      CFA>Tgt
  391.   ELSE
  392.      dup  defer-size -  ' emit  defer-size  compare 0=
  393.      IF
  394.         ( defered )  defer-size -  CFA>Tgt defer-size +
  395.      ELSE
  396.         \
  397.         \ assume it's referencing some CREATE DOES> child...
  398.         \
  399.         ( -- dictadr  )           dup >CFA
  400.         ( -- dictadr it's-cfa )  dup cell- @  $ f,0000 and
  401.         CASE
  402.            VARIABLE_ID of
  403.               dup [ Tracking ' Tracking - ] literal +
  404.               ( -- dictadr cfa cfa+data ) 2 pick -  endof
  405.            CREATE_ID   of
  406.               2dup -           endof
  407.               >newline over
  408.               ." DICT>TGT: address within "  >name ID.
  409.               ."  can't be derived" quit 
  410.         ENDCASE
  411.         ( -- dictadr cfa diff-from-tgt-adr ) swap
  412.         PacketFor    ( -- dictadr diff pkt )  ..@ ref_TgtAdr +  nip
  413.      THEN
  414.   THEN
  415. ;
  416.  
  417.  
  418. 0 .IF
  419. : CreateDoes?  ( adr -- ??_ID , return ID code if not a colon def )
  420.   \
  421.   \ Check if the SFA has a special_ID marked in the SFA...
  422.   \
  423.   dup PacketFor ..@ ref_IsPFA dup
  424.   IF
  425.       drop dup cell- @ $ f,0000 and
  426.   THEN
  427.   swap drop
  428. ;
  429. .THEN
  430.  
  431.  
  432. \ the word that cycles thru a PFA...
  433.  
  434. .need myself
  435.  
  436. : MYSELF  ( -- , compile self )
  437.   latest name> calladr,
  438. ; IMMEDIATE  
  439.  
  440. .then
  441.  
  442.  
  443. : CallingLibOpen?   ( opadr -- flag )
  444.   0 >r  dup @  $ 2d07,2e3c =
  445.   IF
  446.      dup 16 + Calls?
  447.      IF
  448.         ' LibOpen? =
  449.         IF
  450.            rdrop true >r
  451.         THEN
  452.      THEN
  453.   THEN
  454.   drop r>
  455. ;
  456.  
  457. defer DoTracePFA
  458.  
  459. : TraceIVs  ( class-cfa -- )
  460.   dup >LastIvar @   ( -- classCFA lastivar )
  461.   BEGIN
  462.      ?dup
  463.   WHILE
  464.      ( classCFA lastivar )             do-does-size - dup
  465.      ( classCFA insobjcfa insobjcfa )  >IvarClass @ do-does-size - recurse
  466.      >PrevIvar @
  467.   REPEAT
  468.   ( class-cfa -- )  DoTracePFA
  469. ;
  470.  
  471. : CheckIf:Class  ( cfa -- )
  472.   dup cell- @ :CLASS_BIT and
  473.   IF
  474.      \ it's an ODE :CLASS!
  475.      \
  476.      dup >CFATable  ( -- cfa &cfa's )
  477.      dup >#Methods 0
  478.      DO
  479.         dup @ DoTracePFA  cell+
  480.      LOOP
  481.      drop  ( -- cfa )
  482. \
  483. \
  484. [ 0 .if ]
  485.      dup do-does-size +  @ ( -- xxx &cfa's )  CFATable> TraceIVs
  486. [ .else ]
  487.      dup >LastIvar @
  488.      BEGIN
  489.         ?dup
  490.      WHILE
  491.         do-does-size -   dup  DoTracePFA
  492.         dup >IvarClass @ do-does-size - DoTracePFA
  493.         >PrevIvar @
  494.      REPEAT
  495. [ .then ]
  496. \
  497. \
  498.   THEN
  499.   drop
  500. ;
  501.  
  502. : CheckIfClass  ( cfa -- )
  503.   dup PacketFor ..@ ref_IsPFA  \ ValidPFA?
  504.   IF
  505.      dup cell- @ CLASS_BIT and
  506.      IF
  507.         \ it's an ODE CLASS!
  508.         \
  509. \
  510. \
  511. [ 0 .if ]
  512.         dup do-does-size +  @ ( -- xxx &cfa's )
  513.         dup >#Methods 0
  514.         DO
  515.            dup @ DoTracePFA  cell+
  516.         LOOP
  517.         drop
  518. [ .else ]
  519.         dup do-does-size +  @ ( -- xxx &cfa's )  CFATable> TraceIVs
  520. [ .then ]
  521. \
  522. \
  523.      ELSE
  524.         dup CheckIf:Class
  525.      THEN
  526.   THEN
  527.   drop
  528. ;
  529.  
  530. : PCRel>Dest  ( &pcrel-opcode -- reldestadr )
  531.   2+ dup w@ w->s +
  532. ;
  533.  
  534. : Dest>PCRel  ( reldestadr opcode-adr -- rel-offset )
  535.   - 2-
  536. ;
  537.  
  538.  
  539. variable do?pause
  540. variable TrapOn
  541.  
  542. : TracePFA  ( pfa -- )   \ ?pause
  543.   TrapOn @
  544.   IF
  545.      dup TrapOn @ =
  546.      IF
  547.         cr ." TRAPPED: " TrapOn @  .hex
  548.         ." , CfaBase = " CFABASE @ .hex   quit
  549.      THEN
  550.   THEN
  551. \ x ) dbgon >newline cr cr cr dbgoff
  552.   Status?
  553.   IfCreateRefs on
  554. \ x ) dbgon >newline ." TracePFA: before Substitute?" .s >newline dbgoff
  555.   Substitute?
  556. \ x ) dbgon >newline ." TracePFA: after Substitute?: " .s >newline dbgoff
  557.   CFABase @ swap  dup CFABase !
  558.   dup IsValuePFA? 0=
  559.   over references stackfind nip 0= and
  560.   MasterRefsVAR @
  561.   IF
  562.      over MasterRefs StackFind  ( -- pfa flag index flag )  nip 0= and
  563.   THEN
  564.   >r
  565. \
  566. \ Get or create the 'packet' for this pfa...
  567. \
  568.   dup PacketFor         ( -- pfa packet )
  569. \ x ) dbgon >newline ." TracePFA: after PacketFor: " .s >newline dbgoff
  570. \
  571. \ if vectored, pull up executable contents
  572. \
  573.   dup ..@ ref_IsPFA
  574.   IF
  575.      over cell- @ $ f,0000 and   dup USERDEF_ID =  swap GLOBDEF_ID =   or
  576.      IF
  577. \ x ) dbgon >newline ." TracePFA: recursing on defer" .s >newline dbgoff
  578.         over >is @   myself
  579. \ x ) dbgon >newline ." TracePFA: done recursing" .s >newline dbgoff
  580.      THEN
  581.   THEN
  582. \
  583. \ register the fact that its being called...
  584. \
  585.   dup ..@ ref_#times  1+  over ..! ref_#times  r>
  586.   IF
  587. \
  588. \ start the loop checking for more references
  589. \
  590.        >r  0 >r              ( --  opadr )   ( -r- packetadr hibra )
  591.        dup CheckIfClass
  592.        BEGIN
  593.           do?pause @  IF  ?pause  THEN
  594.           dup w@  $ 4e75 -   r@ or
  595.        WHILE
  596. \ x ) dbgon >newline ." TracePFA: not RTS: " dup .hex .s >newline dbgoff
  597.           dup Calls?
  598.           IF
  599.              ( -- opadr calledadr )  myself
  600.           ELSE
  601.              dup ALit?
  602.              IF
  603.                 \ ( -- opadr ref'd-addr )  check if a create/does
  604.                 dup 2- w@ $ 4e75 = >r
  605.                 dup do-does-size -
  606.                 dup cell- @ $ f,0000 and  $ 1,0000 $ 6,0000  within?  >r
  607.                 ValidPFA?  r> and  r> and
  608.                 IF
  609. \ x ) dbgon >newline ." TracePFA: recursing, alit do-does" .s >newline dbgoff
  610.                    do-does-size -  myself  \ some kind of data word
  611. \ x ) dbgon >newline ." TracePFA: done recursing, alit do-does" .s >newline dbgoff
  612.                 ELSE
  613.                    dup ValidPFA?
  614.                    IF
  615. \ x ) dbgon >newline ." TracePFA: recursing, alit cfa" .s >newline dbgoff
  616.                       myself  
  617. \ x ) dbgon >newline ." TracePFA: done recursing, alit cfa" .s >newline dbgoff
  618.                    ELSE
  619. \ x ) dbgon >newline ." TracePFA: recursing, Alit data" .s >newline dbgoff
  620.                       \ is pointing to some kind of data area (ARRAY?)
  621.                       >CFA myself
  622. \ x ) dbgon >newline ." TracePFA: done recursing, alit data" .s >newline dbgoff
  623.                    THEN
  624.                 THEN
  625.              ELSE
  626.                  dup w@ dup PCRel?  swap 1 and 0= and  ( can't calc x(pc,??)
  627.                  IF
  628.                     \ extract addr
  629.                     dup PCRel>Dest  dup ValidPFA?
  630.                    IF
  631. \ x ) dbgon >newline ." TracePFA: recursing, pcrel cfa" .s >newline dbgoff
  632.                       myself  
  633. \ x ) dbgon >newline ." TracePFA: done recursing, pcrel cfa" .s >newline dbgoff
  634.                     ELSE
  635. \ x ) dbgon >newline ." TracePFA: recursing, pcrel data" .s >newline dbgoff
  636.                       \ is pointing to some kind of data area (ARRAY?)
  637.                       >CFA myself
  638. \ x ) dbgon >newline ." TracePFA: done recursing, pcrel data" .s >newline dbgoff
  639.                    THEN
  640.                  THEN
  641.              THEN
  642.           THEN
  643.           dup CallingLibOpen?
  644.           IF
  645.              18 +
  646.           ELSE
  647.              dup w@ >r dup +NextOp  ( -- opadr opsize )  ( -r- hibra opc )
  648.              over + swap            ( -- nextopa opadr )
  649.              r> dup BranchOp?       ( -- nextadr opadr opcode flag )
  650.              IF
  651.                   BRAto? dup r@ >   ( -- nextadr dest replaceflag )
  652.                   IF
  653.                        dup r> drop >r
  654.                   THEN
  655.                   drop              ( -- nextadr )
  656.              ELSE
  657.                   2drop
  658.              THEN
  659.              r@ -dup
  660.              IF
  661.                   ( -- nextadr hibra )
  662.                   over <=
  663.                   IF
  664.                        r> drop  0 >r
  665.                   THEN
  666.              THEN
  667.           THEN
  668.        REPEAT
  669.        r> 2drop  r> drop
  670.   ELSE
  671.        2drop
  672.   THEN
  673.   CFABase !
  674. ;
  675. ' tracepfa is dotracepfa
  676.  
  677. : .Refs   ( -- , show contents of stacks )
  678.   cr  base @ >r
  679.   ReferencesBase freecell dup . ." PFAs referenced ..." cr  ?dup
  680.   IF
  681.        0
  682.        DO
  683.             i cells ReferencesBase + @   ( -- pfa )
  684.             hex dup 9 .r space
  685.             dup packetfor dup ..@ ref_ISPFA
  686.             IF    over >name id.
  687.             ELSE  ." -- No NFA --"
  688.             THEN  space  ascii .  30 emit-to-column space
  689.             swap drop  ( -- packet )
  690.             ..@ ref_#times   decimal  3 .r  ."  times" flushemit ?pause cr
  691.        LOOP
  692.   THEN
  693.   r> base !
  694. ;
  695.  
  696.  
  697. : ShowCalls   ( -- , <name> )
  698.   ReferencesVAR FreeStack
  699.   RefPacketsVAR @&FreeBlocks
  700.   [compile] '  TracePFA
  701.   .refs
  702. ;
  703.  
  704.  
  705. only forth definitions
  706. also TGT
  707.  
  708.